home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / fg.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.5 KB  |  258 lines
  1. (herald (assembler fg t 20))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; What's an FG
  27.  
  28. (define-structure-type fg
  29.   type vars size
  30.   (((pretty-print self stream)
  31.      (pretty-print-fg self stream))))
  32.  
  33.  
  34. (define-structure-type fg-type
  35.   printer 
  36.   ops 
  37.   vals 
  38.   context 
  39.   subfield-indices 
  40.   first-parameter-index
  41.   data?)
  42.  
  43. (define (pretty-print-fg fg stream)
  44.   ((fg-type-printer (fg-type fg)) (fg-vars fg) stream))
  45.  
  46. (define (cons-fg t v)
  47.   (let ((fg (make-fg)))
  48.     (set (fg-type fg) t)
  49.     (set (fg-vars fg) v)
  50.     fg
  51.     ))
  52.  
  53. (define (cons-fg-type p o v c s fpi data?)
  54.   (let ((fgt (make-fg-type)))
  55.     (set (fg-type-printer fgt) p)
  56.     (set (fg-type-ops fgt) o)
  57.     (set (fg-type-vals fgt) v)
  58.     (set (fg-type-context fgt) c)
  59.     (set (fg-type-subfield-indices fgt) s)
  60.     ;; so that given an FG we can get the args passed to it.
  61.     (set (fg-type-first-parameter-index fgt) fpi)        
  62.     (set (fg-type-data? fgt) data?)
  63.     fgt
  64.     ))
  65.  
  66. (define-integrable (fg-argref fg n)
  67.    (vref (fg-vars fg) (fx+ n (fg-type-first-parameter-index (fg-type fg)))))
  68.                                                         
  69. ;;; These are for defined fg predicates.
  70.  
  71. (define-operation (get-fg-type fg-maker)
  72.    (error "not an fg maker: (GET-FG-TYPE ~s)" fg-maker))
  73.  
  74. (define (fg-predicator fg-maker)
  75.   (let ((ft (get-fg-type fg-maker)))
  76.     (lambda (obj) 
  77.        (and (fg? obj) 
  78.             (eq? (fg-type obj) ft)))))
  79.  
  80. (define (data-fg? fg)
  81.     (and (fg? fg) (fg-type-data? (fg-type fg))))
  82.  
  83. ;;; COMPRESS-FG
  84.  
  85. (define (compress-fg fg)
  86.   (let* ((fgt (fg-type fg))
  87.          (vars (fg-vars fg))
  88.          (vals (fg-type-vals fgt)))
  89.     (iterate loop ((ops (fg-type-ops fgt)))
  90.       (cond ((null? ops) fg)
  91.             (else
  92.              (xselect (car ops)
  93.                ((wop/fix)
  94.                 (destructure (((#f sign width vop voc1 . ops) ops))
  95.                   (loop ops)))
  96.                ((wop/@fix)
  97.                 (destructure (((#f sign width-i vop voc1 . ops) ops))
  98.                   (loop ops)))
  99.                ((wop/proc)
  100.                 (destructure (((#f sign cw-i proc-i vop voc1 . ops) ops))
  101.                   (format t "~&computed width in ~s~%" fg)
  102.                   (let ((width ((vref vals proc-i) vars)))
  103.                     (set (vref vars cw-i) width)
  104.                     (loop ops))))
  105.  
  106.                ((wop/var)
  107.                 (destructure (((#f sign cw-i opt-i vop voc1 . ops) ops))
  108.                   (let ((opts (vref vals opt-i))
  109.                         (val (get-fixed-value vop voc1 vars vals)))
  110.                     (set (vref vars cw-i)
  111.                          (cond (val (choose-width opts (fxn= sign 0) val))
  112.                                (else 
  113.                                 (no-op (error "non fixed value in v field"))
  114.                                 ))))
  115.                   (loop ops)))
  116.                ((wop/depending-on)
  117.                 (destructure (((#f sdf#-i sdf-i mark-i fge-i . ops) ops))
  118.                   (loop ops)))
  119.  
  120.                ((wop/subfield-ic)
  121.                 (destructure (((#f sf-i vop voc1 . ops) ops))
  122.                   (let ((sf (vref vars sf-i)))
  123.                     (let ((sf (cond ((fixnum? sf)
  124.                                      ;(format t "got sf=~s~%" sf)
  125.                                      (let ((real-sf ((vref vals sf) vars)))
  126.                                        (set (vref vars sf-i) real-sf)
  127.                                        ;(format t "got real sf=~s~%" real-sf)
  128.                                        real-sf))
  129.                                     (else 
  130.                                      sf))))
  131.                       (if (not (fg? sf))
  132.                           (error "non-fg ~s in fg ~s" sf fg))
  133.                       (context-fg sf)
  134.                       (compress-fg sf)
  135.                       (loop ops)))))
  136.  
  137.                ((wop/mark)
  138.                 (destructure (((#f marker-i . ops) ops))
  139.                   (loop ops)))
  140.                ))))))
  141.  
  142. ;;; CHOOSE-WIDTH & friends.  
  143.  
  144. (define (choose-width opts signed? val)
  145.   (let ((want (integer-field-size val signed?)))
  146.     (iterate loop ((l opts))
  147.         (cond ((null? l)
  148.                (error "no width fits~%  (choose-width ~s ~s ~s)"
  149.                       opts signed? val))
  150.               ((fx>= (car l) want) (car l))
  151.               (else (loop (cdr l)))))))
  152.  
  153. (define-integrable (integer-field-size n signed?)
  154.   (if (not (fixnum? n)) (error "integer-field-size on non fixnum"))
  155.   (if signed?
  156.       (signed-field-size n)
  157.       (unsigned-field-size n)))
  158.  
  159. (define-integrable (signed-field-size n)
  160.   (fx+ (if (fx>= n 0)
  161.            (fixnum-howlong n)
  162.            (fixnum-howlong (fx- -1 n)))
  163.        1))
  164.  
  165. (define-integrable (unsigned-field-size n)
  166.   (if (fx>= n 0)
  167.       (fixnum-howlong n)
  168.       (error "(unsigned-field-size ~s)" n))) ; (fixnum-howlong (fx- -1 n))
  169.  
  170.  
  171.  
  172. ;;;; CONTEXT-FG - called after a fg has been instantiated (so it knows 
  173. ;;; all its subfields).  Each subfield that needs to know its context 
  174. ;;; is womped with it.
  175.  
  176. (define (context-fg fg)
  177.   (if (not (fg? fg))
  178.       (error "trying to set context for non-fg ~s" fg))
  179.   (let* ((fgt (fg-type fg))
  180.          (sfi's (fg-type-subfield-indices fgt)))
  181.     (let ((vars (fg-vars fg))
  182.           (vals (fg-type-vals fgt)))
  183.       (iterate loop ((ops (fg-type-ops fgt))
  184.                      (sfi's sfi's))
  185.         (cond ((null? sfi's) fg)
  186.               (else
  187.                (let ((ops (nthcdr ops (car sfi's))))
  188.                  (destructure (((#f subfg-i vop voc1) ops))
  189.                    (let ((subfg (vref vars subfg-i)))
  190.                      ;; can't contextify <expr> subfgs
  191.                      (cond ((not (fixnum? subfg))
  192.                             (if (fg-type-context (fg-type subfg))
  193.                                (let ((context (get-value vop voc1 vars vals)))
  194.                                  (set-context-in-subfg subfg context))))))
  195.                    (loop ops (cdr sfi's))))))))))
  196.  
  197. (define (set-context-in-subfg subfg context)
  198.   (cond ((neq? (fg-type-context (fg-type subfg)) (car context))
  199.          (error "sub-field ~s not valid in context ~s"
  200.                 subfg context))
  201.         (else
  202.          (let ((vars (fg-vars subfg)))
  203.            (do ((i 0 (fx+ i 1))
  204.                 (l (cdr context) (cdr l)))
  205.                ((null? l) subfg)
  206.              (set (vref vars i) (car l)))))))
  207.                                  
  208. ;;; DESTRUCTURE-FG.  This is kind of a hack for pulling an FG apart, 
  209. ;;; after it has been made.  Returns field value, field width, 
  210. ;;; and undated start.
  211.  
  212. (define (destructure-fg fg start)
  213.   (let* ((fgt (fg-type fg))
  214.          (vars (fg-vars fg))
  215.          (vals (fg-type-vals fgt))
  216.          (ops  (fg-type-ops fgt))
  217.          (ops (nthcdr ops start)))
  218.      (cond ((null? ops)
  219.             (return nil 0 start))
  220.            (else
  221.             (select (car ops)
  222.               ((wop/fix)
  223.                (destructure (((#f sign width vop voc1 . ops) ops))
  224.                  (return (get-value vop voc1 vars vals) 
  225.                          width 
  226.                          (fx+ start 5))))
  227.               ((wop/@fix)
  228.                (destructure (((#f sign width-i vop voc1 . ops) ops))
  229.                  (return (get-value vop voc1 vars vals) 
  230.                          (vref vars width-i)
  231.                          (fx+ start 5))))
  232.               ((wop/proc)
  233.                (destructure (((#f sign cw-i proc-i vop voc1 . ops) ops))
  234.                  (return (get-value vop voc1 vars vals) 
  235.                          (vref vars cw-i)
  236.                          (fx+ start 6))))
  237.               ((wop/var)
  238.                (destructure (((#f sign cw-i opt-i vop voc1 . ops) ops))
  239.                  (return (get-value vop voc1 vars vals) 
  240.                          (vref vars cw-i)
  241.                          (fx+ start 6))))
  242.  
  243.               ((wop/depending-on)
  244.                (destructure (((#f sdf#-i sdf-i mark-i fge-i . ops) ops))
  245.                  (error "can't do depending-on in DESTRUCTURE-FG")))
  246.               ((wop/subfield-ic)
  247.                (destructure (((#f sf-i vop voc1 . ops) ops))
  248.                  (error "can't do subfield in DESTRUCTURE-FG")))
  249.               ((wop/mark)
  250.                (destructure (((#f marker-i . ops) ops))
  251.                  (return 0 0 (fx+ start 2))))
  252.               (else
  253.                (error "bad start~%  (DESTRUCTURE-FG ~s ~s)" fg start))
  254.               )))))
  255.  
  256.  
  257.  
  258.